source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMV321.m@ 1499

Last change on this file since 1499 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1DGPMV321 ;ALB/MIR - ASIH TRANSFER ; 10 DEC 89 @9
2 ;;5.3;Registration;**40,208,713**;Aug 13, 1993
3ECA ;Edit corresponding admission for ASIH transfers
4 S DGPMTN=DGPMA,DGPMNI=DGPMCA D FINDLAST^DGPMV32
5 S DGPMNA=0,DGPMAA=$P(DGPMA,"^",15) I '$D(^DGPM(+DGPMAA,0)) D NEW S DGPMNA=1,DIE("NO^")=""
6 W !,"Editing Corresponding Hospital Admission",!
7 I 'DGPMNA,$D(^DGPM(+DGPMAA,0)) S DA=$P(^(0),"^",16) I $D(^DGPT(+DA,0)) S DIE="^DGPT(",DR="2////"_+DGPMA_";20;" K DQ,DG D ^DIE W ! ;update admission d/t in PTF
8 ;update pseudo discharge
9 S X1=+DGPMAB,X2=30 D C^%DTC
10 I 'DGPMNA,(+DGPMA'=+DGPMP) S DA=$P(DGPMAN,"^",17) I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,3,DA,"P")=$S($D(^UTILITY("DGPM",$J,3,DA,"P")):^("P"),1:^DGPM(DA,0)),DIE="^DGPM(",DR=".01///"_X K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,3,DA,"A")=^DGPM(DA,0)
11 S DA=DGPMAA,DR="[DGPM ASIH ADMIT]",DIE="^DGPM(" I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,1,DA,"P")=$S($D(^UTILITY("DGPM",$J,1,DA,"P")):^("P"),1:^DGPM(DA,0)) S:DGPMN DIE("NO^")="" K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,1,DA,"A")=^DGPM(DA,0)
12 I '$P(^DGPM(DGPMDA,0),"^",6) D UNDO^DGPMV322 Q
13 S:$D(Y) DGPMOUT=1 S Y=DGPMAA_"^1" D:'DGPMOUT SPEC^DGPMV36
14 I '$D(^DGPM("APHY",DGPMAA)) D UNDO^DGPMV322 Q
15 ; DG*713 - send admission bulletin
16 D ^DGPMVBUR
17 K DGPMAA,DGPMAB,DGPMNA,DGPMPTF Q
18UHD ;Update hospital discharge and PTF record
19 S X=("^"_$P(DGPM0,"^",18)_"^") G:"^43^45^"[X DEL Q:"^13^44^"'[X
20 ;Update hospital discharge
21 G DEL:(+DGPMA=+DGPMP)
22 S DA=$S($D(^DGPM(+$P(DGPM0,"^",15),0)):$P(^(0),"^",17),1:0)
23 I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,3,DA,"P")=$S($D(^UTILITY("DGPM",$J,3,DA,"P")):^("P"),1:^DGPM(DA,0)),DR=".01///"_+DGPMA_";102////"_DUZ_";103///NOW",DIE="^DGPM(" K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,3,DA,"A")=^DGPM(DA,0)
24 I +DGPMP'=+DGPMA S DA=$P(^DGPM(+$P(DGPM0,"^",15),0),"^",16) I $D(^DGPT(+DA,0)) S DIE="^DGPT(",DR="70////"_+DGPMA K DQ,DG D ^DIE ;update discharge date for hospital PTF
25DEL ;conditionally delete WHILE ASIH or DISCHARGE FROM NHCU/DOM WHILE ASIH discharge if no longer ASIH
26 I DGPMTYP="^14^",$P(DGPMAN,U,17) D
27 . N X
28 . S X=$G(^DGPM(+$P(DGPMAN,U,17),0)) ; discharge node
29 . I $P(X,"^",18)'=42,($P(X,"^",18)'=47) Q ; not WHILE ASIH or DISCHARGE FROM NHCU/DOM WHILE ASIH
30 . S X=9999999.9999999-+X ; inverse date of discharge movement
31 . S X=$O(^DGPM("APMV",DFN,DGPMCA,X)),X=$O(^(+X,0)) ; last movement ien
32 . S X=$P($G(^DGPM(+X,0)),"^",18) I "^13^43^44^45^"[("^"_X_"^") Q ; still actively ASIH
33 . S DGPMAA=DGPMAN,DGPMAI=DGPMCA
34 . D DEL^DGPMV331
35 Q
36NEW ;Add new corresponding admission to file
37 W !!,"Creating new hospital admission"
38 S DGMAS=40 D FAMT^DGPMV30 ; get active mvt type for TO ASIH admission
39 S X=+DGPMA,DGPM0ND=+DGPMA_"^"_1_"^"_DFN_"^"_DGFAC_"^^^^^^^^^^"_DA_"^^^^^^^"_+DGPMDA_"^"_2 D NEW^DGPMV3 S DGPMAA=+Y K DGFAC
40 S ^UTILITY("DGPM",$J,1,+Y,"P")="",^UTILITY("DGPM",$J,1,+Y,"A")=$G(^DGPM(+Y,0))
41 ;
42 ;now update transfer movement with ASIH ADMISSION and ASIH SEQUENCE
43 S DIE="^DGPM(",DA=DGPMDA,DR=".15////"_DGPMAA_";.22////"_1 K DQ,DG D ^DIE
44 ;
45 ;create new PTF entry
46 W !,"Creating PTF record for new hospital admission",!
47 S Y=+DGPMA D CREATE^DGPTFCR S DGPMPTF=+Y
48 ;
49 ;update hospital admission with PTF NUMBER
50 S DIE="^DGPM(",DA=DGPMAA,DR=".16////"_DGPMPTF K DQ,DG I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,1,DA,"P")=$S($D(^UTILITY("DGPM",$J,1,DA,"P")):^("P"),1:^DGPM(DA,0)) D ^DIE S ^UTILITY("DGPM",$J,1,DA,"A")=^DGPM(DA,0)
51 Q:DGPMTYP="^44^" ;if RESUME ASIH, already have 30 day discharge
52 ;
53ASIHOF ;entry when transferring TO ASIH (OTHER FACILITY) to create 30 day discharge
54 ;create pseudo discharge for NHCU/DOM admission - 30 days from first transfer of TO ASIH or TO ASIH (OTHER FACILITY)
55 W !,"Creating 30 day pseudo discharge for NHCU/DOM admission"
56 S DGMAS=42 D FAMT^DGPMV30 ; get active mvt type for WHILE ASIH discharge
57 S X1=+DGPMAB,X2=30 D C^%DTC S DGPMPD=X,DGPM0ND=X_"^"_3_"^"_DFN_"^"_DGFAC_"^^^^^^^^^^"_+DGPMCA,Y=+$P($G(^DGPM(+DGPMCA,0)),U,17)
58 I $P($G(^DGPM(+Y,0)),U,4)=DGFAC D
59 .N DIE,DA S DIE="^DGPM(",DA=+Y N Y S DR=".01////^S X="_X D ^DIE
60 D:'Y NEW^DGPMV3 S DGPMAD=+Y K DGFAC
61 S ^UTILITY("DGPM",$J,3,+Y,"P")="",^UTILITY("DGPM",$J,3,+Y,"A")=$G(^DGPM(+Y,0))
62 ;
63 ;update NHCU/DOM PTF entry with DISCHARGE DATE, TYPE OF DISPOSITION
64 S DIE="^DGPT(",DA=$P(DGPMAN,"^",16),DR="70////"_DGPMPD_";72////"_1 K DQ,DG I $D(^DGPT(+DA,0)) D ^DIE
65 ;
66 ;update NHCU admission with DISCHARGE MOVEMENT
67 K DGPMAD,DGPMPD,DGPMPTF Q
Note: See TracBrowser for help on using the repository browser.