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 Oct 16, 2024@18:58:52 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
