- DGRUGC ;ALB/BOK/MLI - CREATE A PATIENT ASSESSMENT RECORD ; 27 OCT 86
- ;;5.3;Registration;**7,89,99**;Aug 13, 1993
- EN D Q
- EN1 K DIC S DIC(0)="AMEQZ",DIC="^DPT(" D ^DIC G Q:Y'>0 S DFN=+Y
- I '$D(DGCNH) S DIC("A")="Select PATIENT ADMISSION: ",DIC(0)="AEQZ",DIC="^DGPM(",DIC("S")="I $P(^(0),U,2)=1" W ! D DFN^DGPMUTL G Q:Y'>0 W ! S (DA,DGDE)=+Y G NOAD:'$D(^DGPM(+Y,0))
- ASK I '$D(DGCNH) S X="" W !!,"(A)dmission/transfer or (S)emi Annual Census: A//"
- I '$D(DGCNH) S Z="^ADMISSION TRANSFER^SEMI ANNUAL" R X:DTIME G Q:X["^"!('$T) I X="" S X="A" W X
- I '$D(DGCNH) D IN^DGHELP I %=-1 W !!,?12,"CHOOSE FROM:",!?12,"A - Assessment purpose is admission transfer",!?12,"S - Assessment purpose is semi-annual census",! S %="" G ASK
- I $D(DGCNH) S DGAP=3
- I '$D(DGCNH) S DGAP=$S(X="A":1,1:2) I DGAP=2 S DGSEMI=""
- I '$D(DGCNH) S DGNO=0,DGCR="" I $D(^DGPM(DGDE,0)) S (DGAD,DGDT)=$P(^(0),U),DGWD=$P(^(0),U,6),DFN=$P(^(0),U,3) D WDCK
- I '$D(DGCNH) F I=DGAD:0 S I=$O(^DGPM("APCA",DFN,DGDE,I)) Q:'I F J=0:0 S J=$O(^DGPM("APCA",DFN,DGDE,I,J)) Q:'J I $D(^DGPM(J,0)) S DGDT=+^(0),DGWD=$P(^(0),U,6) D WDCK
- I '$D(DGCNH),'$D(^UTILITY($J,"DTS")) W !,"NEITHER ADMISSION NOR TRANSFERS ARE TO INTERMEDIATE CARE OR NURSING HOME WARDS",!?8,"AFTER THE LAST CLOSEOUT" D QUIT G EN
- I '$D(DGCNH) D SELECT^DGRUGC1 G EN:DGFL!'$D(DGD) S DGD=$P(DGD,".") I DGAP=1,$D(^DG(45.9,"AT",DGAP,DGD,DFN)) W !!,*7,"There is already an admission/transfer assessment created for that",!,"admission/transfer date",! D QUIT G EN1
- I $D(DGCNH) S DGI="",DGCR=""
- S X=DFN,DIC="^DG(45.9,",DIC(0)="L" D FILE^DICN G BUL^DGRUGBGJ:Y'>0 S DA=+Y,$P(^DG(45.9,DA,0),U,6)=DGAP,$P(^(0),U,9)=$P(DGI,U,2)
- S:'$D(DGCNH) $P(^("R"),U)=$P(DGI,U)_";"_"DIC(42,"
- I $D(DGCNH),$P(DGI,U)'="" S $P(^("R"),U)=$P(DGI,U)_";"_"FBAAV("
- S DIE="^DG(45.9,",DR="[DGRUG]" S:'$D(DGCNH) DIE("NO^")="" D ^DIE
- I $D(Y) D REMOVE(DA) W !,"Record Deleted." Q
- I '$D(DGCNH) W !,"ADMISSION/TRANSFER DATE: " S Y=DGD D DT^DIQ
- I $D(DGCNH) D
- . N X,Y,DIR
- . S DIR(0)="45.9,7AO",DIR("A")="ADMISSION/TRANSFER DATE: " D ^DIR
- . S DGD=$G(Y(0))
- W !!,"ASSESSMENT RECORD CREATED",!! S DR="7///"_DGD_";80///5" D ^DIE D QUIT G EN
- QUIT K ^UTILITY($J),%,%Y,DA,DFN,DGA1,DGAD,DGAP,DGCO,DGCR,DGCT,DGD,DGDE,DGDT,DGFL,DGFT,DGFY,DGI,DGII,DGNO,DGPT,DGR,DGSV,DGT,DGWD,DGX,DICR,DIE,DIK,DIC,DIV,DR,I,J,K,X,Y,Z
- K DIRUT,DUOUT,DTOUT,DIROUT
- I $D(DGFCNH) K DGFCNH,DGCNH
- Q
- Q D QUIT K DIC,DFN,DGAP,DGSEMI Q
- REMOVE(DA) ;
- S DIK="^DG(45.9," D ^DIK K DIK,DA G QUIT
- NOAD W !,*7,"THERE ARE NO ADMISSIONS ON FILE FOR THIS PATIENT" G EN
- DEL S DA=DFN,DIK="^DG(45.9," D ^DIK K DIK,DA G QUIT
- WR I $D(^(0)) S DGR=^(0),DGAD=$P(DGR,U,2),DA=+Y I DGAD W:'$D(DICR) $P($S($D(^DPT(+DGR,0)):^(0),1:""),U,9) W " ","Assessment date: " S Y=DGAD D DT^DIQ S Y=DA
- K DGAD,DGR Q
- OPEN W !! S DIC="^DG(45.9,",DIC(0)="AEQMN",DIC("S")="I $$OSCREEN^DGRUGU1()",DIC("A")="Enter the PAF record to reopen: " D ^DIC G QUIT:Y'>0 S DA=+Y,DIC(0)="NE",X=DA K DIC("S")
- OKO W !!,DA," ",$P(^DPT(+^DG(45.9,DA,0),0),U,1) S %=2 W !,"Ok to reopen" D YN^DICN I %Y["?" D YN G OKO
- I %=1 S DR="80///1",DIE="^DG(45.9," D ^DIE W !!,"*OPENED*"
- K DIC G QUIT
- KIL W !! S DIC("S")="I $$KSCREEN^DGRUGU1(Y)",DIC="^DG(45.9,",DIC(0)="AEQMN",DIC("A")="Enter PAF record to delete: " D ^DIC G QUIT:Y'>0 S DA=+Y,X=DA K DIC("S")
- OKD S %=2 W !,"Ok to delete ",$P(^DPT(+^DG(45.9,DA,0),0),U,1)," PAF record " D YN^DICN I %Y["?" D YN G OKD
- I %=1 S DIK=DIC D ^DIK W !,"*DELETED*" K DIC G QUIT
- I '% W !,"Answer YES or NO",! G KIL
- G QUIT
- CLOSE D LO^DGUTL W !! S DIC("S")="I $$CSCREEN^DGRUGU1()",DIC="^DG(45.9,",DIC(0)="AEQMN",DIC("A")="Enter PAF record to close: " D ^DIC K DIC G QUIT:Y'>0 S DA=+Y K DIC("S")
- OKC S %=1 W !,"Ok to close" D YN^DICN I %Y["?" D YN G OKC
- I %=1 S DR="80///2;81///"_DT_";82////"_DUZ,DIE="^DG(45.9," D ^DIE W !!,"*CLOSED*"
- K DA,DIC,DIE,DR G CLOSE
- WDCK I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
- S DGCO=0 D CLOUT I (DGCO!$D(DGSEMI))&$D(^DIC(42,+DGWD,0)) S DGSV=$P(^(0),U,3) I DGSV]"","NHI"[DGSV S DGNO=DGNO+1,^UTILITY($J,"DTS",DGNO,10000000-DGDT,DGDT)=DGWD_"^"_$E(DGSV) I DGDT=DGAD S ^(DGDT)=^(DGDT)_"^"_"*"
- Q
- YN W !?5,"ANSWER 'Y'ES OR 'N'O" Q
- CLOUT S DGCO=$E(DT,1,3)-$S($E(DT,4,7)<600:1,1:0)_$S($E(DT,4,7)<600:1001,1:"0401") S DGCO=$S(DGCO>DGDT:0,1:1) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUGC 4245 printed Feb 19, 2025@00:24:21 Page 2
- DGRUGC ;ALB/BOK/MLI - CREATE A PATIENT ASSESSMENT RECORD ; 27 OCT 86
- +1 ;;5.3;Registration;**7,89,99**;Aug 13, 1993
- EN DO Q
- EN1 KILL DIC
- SET DIC(0)="AMEQZ"
- SET DIC="^DPT("
- DO ^DIC
- if Y'>0
- GOTO Q
- SET DFN=+Y
- +1 IF '$DATA(DGCNH)
- SET DIC("A")="Select PATIENT ADMISSION: "
- SET DIC(0)="AEQZ"
- SET DIC="^DGPM("
- SET DIC("S")="I $P(^(0),U,2)=1"
- WRITE !
- DO DFN^DGPMUTL
- if Y'>0
- GOTO Q
- WRITE !
- SET (DA,DGDE)=+Y
- if '$DATA(^DGPM(+Y,0))
- GOTO NOAD
- ASK IF '$DATA(DGCNH)
- SET X=""
- WRITE !!,"(A)dmission/transfer or (S)emi Annual Census: A//"
- +1 IF '$DATA(DGCNH)
- SET Z="^ADMISSION TRANSFER^SEMI ANNUAL"
- READ X:DTIME
- if X["^"!('$TEST)
- GOTO Q
- IF X=""
- SET X="A"
- WRITE X
- +2 IF '$DATA(DGCNH)
- DO IN^DGHELP
- IF %=-1
- WRITE !!,?12,"CHOOSE FROM:",!?12,"A - Assessment purpose is admission transfer",!?12,"S - Assessment purpose is semi-annual census",!
- SET %=""
- GOTO ASK
- +3 IF $DATA(DGCNH)
- SET DGAP=3
- +4 IF '$DATA(DGCNH)
- SET DGAP=$SELECT(X="A":1,1:2)
- IF DGAP=2
- SET DGSEMI=""
- +5 IF '$DATA(DGCNH)
- SET DGNO=0
- SET DGCR=""
- IF $DATA(^DGPM(DGDE,0))
- SET (DGAD,DGDT)=$PIECE(^(0),U)
- SET DGWD=$PIECE(^(0),U,6)
- SET DFN=$PIECE(^(0),U,3)
- DO WDCK
- +6 IF '$DATA(DGCNH)
- FOR I=DGAD:0
- SET I=$ORDER(^DGPM("APCA",DFN,DGDE,I))
- if 'I
- QUIT
- FOR J=0:0
- SET J=$ORDER(^DGPM("APCA",DFN,DGDE,I,J))
- if 'J
- QUIT
- IF $DATA(^DGPM(J,0))
- SET DGDT=+^(0)
- SET DGWD=$PIECE(^(0),U,6)
- DO WDCK
- +7 IF '$DATA(DGCNH)
- IF '$DATA(^UTILITY($JOB,"DTS"))
- WRITE !,"NEITHER ADMISSION NOR TRANSFERS ARE TO INTERMEDIATE CARE OR NURSING HOME WARDS",!?8,"AFTER THE LAST CLOSEOUT"
- DO QUIT
- GOTO EN
- +8 IF '$DATA(DGCNH)
- DO SELECT^DGRUGC1
- if DGFL!'$DATA(DGD)
- GOTO EN
- SET DGD=$PIECE(DGD,".")
- IF DGAP=1
- IF $DATA(^DG(45.9,"AT",DGAP,DGD,DFN))
- WRITE !!,*7,"There is already an admission/transfer assessment created for that",!,"admission/transfer date",!
- DO QUIT
- GOTO EN1
- +9 IF $DATA(DGCNH)
- SET DGI=""
- SET DGCR=""
- +10 SET X=DFN
- SET DIC="^DG(45.9,"
- SET DIC(0)="L"
- DO FILE^DICN
- if Y'>0
- GOTO BUL^DGRUGBGJ
- SET DA=+Y
- SET $PIECE(^DG(45.9,DA,0),U,6)=DGAP
- SET $PIECE(^(0),U,9)=$PIECE(DGI,U,2)
- +11 if '$DATA(DGCNH)
- SET $PIECE(^("R"),U)=$PIECE(DGI,U)_";"_"DIC(42,"
- +12 IF $DATA(DGCNH)
- IF $PIECE(DGI,U)'=""
- SET $PIECE(^("R"),U)=$PIECE(DGI,U)_";"_"FBAAV("
- +13 SET DIE="^DG(45.9,"
- SET DR="[DGRUG]"
- if '$DATA(DGCNH)
- SET DIE("NO^")=""
- DO ^DIE
- +14 IF $DATA(Y)
- DO REMOVE(DA)
- WRITE !,"Record Deleted."
- QUIT
- +15 IF '$DATA(DGCNH)
- WRITE !,"ADMISSION/TRANSFER DATE: "
- SET Y=DGD
- DO DT^DIQ
- +16 IF $DATA(DGCNH)
- Begin DoDot:1
- +17 NEW X,Y,DIR
- +18 SET DIR(0)="45.9,7AO"
- SET DIR("A")="ADMISSION/TRANSFER DATE: "
- DO ^DIR
- +19 SET DGD=$GET(Y(0))
- End DoDot:1
- +20 WRITE !!,"ASSESSMENT RECORD CREATED",!!
- SET DR="7///"_DGD_";80///5"
- DO ^DIE
- DO QUIT
- GOTO EN
- QUIT KILL ^UTILITY($JOB),%,%Y,DA,DFN,DGA1,DGAD,DGAP,DGCO,DGCR,DGCT,DGD,DGDE,DGDT,DGFL,DGFT,DGFY,DGI,DGII,DGNO,DGPT,DGR,DGSV,DGT,DGWD,DGX,DICR,DIE,DIK,DIC,DIV,DR,I,J,K,X,Y,Z
- +1 KILL DIRUT,DUOUT,DTOUT,DIROUT
- +2 IF $DATA(DGFCNH)
- KILL DGFCNH,DGCNH
- +3 QUIT
- Q DO QUIT
- KILL DIC,DFN,DGAP,DGSEMI
- QUIT
- REMOVE(DA) ;
- +1 SET DIK="^DG(45.9,"
- DO ^DIK
- KILL DIK,DA
- GOTO QUIT
- NOAD WRITE !,*7,"THERE ARE NO ADMISSIONS ON FILE FOR THIS PATIENT"
- GOTO EN
- DEL SET DA=DFN
- SET DIK="^DG(45.9,"
- DO ^DIK
- KILL DIK,DA
- GOTO QUIT
- WR IF $DATA(^(0))
- SET DGR=^(0)
- SET DGAD=$PIECE(DGR,U,2)
- SET DA=+Y
- IF DGAD
- if '$DATA(DICR)
- WRITE $PIECE($SELECT($DATA(^DPT(+DGR,0)):^(0),1:""),U,9)
- WRITE " ","Assessment date: "
- SET Y=DGAD
- DO DT^DIQ
- SET Y=DA
- +1 KILL DGAD,DGR
- QUIT
- OPEN WRITE !!
- SET DIC="^DG(45.9,"
- SET DIC(0)="AEQMN"
- SET DIC("S")="I $$OSCREEN^DGRUGU1()"
- SET DIC("A")="Enter the PAF record to reopen: "
- DO ^DIC
- if Y'>0
- GOTO QUIT
- SET DA=+Y
- SET DIC(0)="NE"
- SET X=DA
- KILL DIC("S")
- OKO WRITE !!,DA," ",$PIECE(^DPT(+^DG(45.9,DA,0),0),U,1)
- SET %=2
- WRITE !,"Ok to reopen"
- DO YN^DICN
- IF %Y["?"
- DO YN
- GOTO OKO
- +1 IF %=1
- SET DR="80///1"
- SET DIE="^DG(45.9,"
- DO ^DIE
- WRITE !!,"*OPENED*"
- +2 KILL DIC
- GOTO QUIT
- KIL WRITE !!
- SET DIC("S")="I $$KSCREEN^DGRUGU1(Y)"
- SET DIC="^DG(45.9,"
- SET DIC(0)="AEQMN"
- SET DIC("A")="Enter PAF record to delete: "
- DO ^DIC
- if Y'>0
- GOTO QUIT
- SET DA=+Y
- SET X=DA
- KILL DIC("S")
- OKD SET %=2
- WRITE !,"Ok to delete ",$PIECE(^DPT(+^DG(45.9,DA,0),0),U,1)," PAF record "
- DO YN^DICN
- IF %Y["?"
- DO YN
- GOTO OKD
- +1 IF %=1
- SET DIK=DIC
- DO ^DIK
- WRITE !,"*DELETED*"
- KILL DIC
- GOTO QUIT
- +2 IF '%
- WRITE !,"Answer YES or NO",!
- GOTO KIL
- +3 GOTO QUIT
- CLOSE DO LO^DGUTL
- WRITE !!
- SET DIC("S")="I $$CSCREEN^DGRUGU1()"
- SET DIC="^DG(45.9,"
- SET DIC(0)="AEQMN"
- SET DIC("A")="Enter PAF record to close: "
- DO ^DIC
- KILL DIC
- if Y'>0
- GOTO QUIT
- SET DA=+Y
- KILL DIC("S")
- OKC SET %=1
- WRITE !,"Ok to close"
- DO YN^DICN
- IF %Y["?"
- DO YN
- GOTO OKC
- +1 IF %=1
- SET DR="80///2;81///"_DT_";82////"_DUZ
- SET DIE="^DG(45.9,"
- DO ^DIE
- WRITE !!,"*CLOSED*"
- +2 KILL DA,DIC,DIE,DR
- GOTO CLOSE
- WDCK IF '$DATA(DT)
- SET %DT=""
- SET X="T"
- DO ^%DT
- SET DT=Y
- +1 SET DGCO=0
- DO CLOUT
- IF (DGCO!$DATA(DGSEMI))&$DATA(^DIC(42,+DGWD,0))
- SET DGSV=$PIECE(^(0),U,3)
- IF DGSV]""
- IF "NHI"[DGSV
- SET DGNO=DGNO+1
- SET ^UTILITY($JOB,"DTS",DGNO,10000000-DGDT,DGDT)=DGWD_"^"_$EXTRACT(DGSV)
- IF DGDT=DGAD
- SET ^(DGDT)=^(DGDT)_"^"_"*"
- +2 QUIT
- YN WRITE !?5,"ANSWER 'Y'ES OR 'N'O"
- QUIT
- CLOUT SET DGCO=$EXTRACT(DT,1,3)-$SELECT($EXTRACT(DT,4,7)<600:1,1:0)_$SELECT($EXTRACT(DT,4,7)<600:1001,1:"0401")
- SET DGCO=$SELECT(DGCO>DGDT:0,1:1)
- QUIT