DGFI ;ALB/JDS-MRL - FEMALE INPATIENT OUTPUTS ; 19 JUN 87
;;5.3;Registration;;Aug 13, 1993
;
S DIC="^DPT(",L=0,BY="'.1,"
S FR=",",TO="," I $D(^DG(43,1,"GL")) S:$P(^("GL"),U,2) BY=BY_".19,",FR=FR_",",TO=TO_","
S BY=BY_"@SEX,.01",FR=FR_"E,",TO=TO_"F,",X=3,DGNO=0 D ^DGTEMP G Q:DGNO S FLDS=X
D EN1^DIP
Q K BY,TO,FR,DIC,DIS,X,DGNO,DHD Q
EN K TD,DGF S %DT="AEPT",%DT("A")="Enter date of Stay: " D ^%DT G Q1:Y'>0 G EN:+Y>(DT+1) S DGT=+Y,DG2=DGT,L=0,DGT=$S(DGT[".":DGT,1:DGT_".2400"),DG2=DGT
EN1 S Y=DGT X ^DD("DD") S DHD="FEMALE INPATIENT FOR "_Y,L=0
S DIS(1)="S DFN=D0 D ^DGINPW,SET^DGFI I DG1 S ^UTILITY($J,""DG"",D0)=DG1"
S DIC="^DPT(",BY="@SEX",X=4,DGNO=0 D ^DGTEMP G Q:DGNO S FLDS=X,FR="F,",TO="FZ,"
I '$D(TD),$D(^DG(43,1,"GL")) S:$P(^("GL"),U,2) BY=BY_",999;""DIVISION: """,FR=FR_"@,",TO=TO_","
S BY=BY_",.01" D EN1^DIP
Q:$D(DGF) K DGT
Q1 K %DT,DFN,DG1,DG2,DGA1,DGX,FLDS,L,POP,^UTILITY($J,"DG") G Q
SET Q:'DG1 S $P(DG1,U,4)=+DG1,$P(DG1,U,1)=+^DGPM(DGA1,0),X=$P(DG1,U,2),$P(DG1,U,10)=$S(X]"":$P(^DG(405.4,+X,0),"^",1),1:"") I $P(DG1,U,3)]"","^1^2^3^13^25^26^43^44^45^"[("^"_$P(DG1,U,3)_"^") S DG1=""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGFI 1128 printed Nov 22, 2024@17:53:33 Page 2
DGFI ;ALB/JDS-MRL - FEMALE INPATIENT OUTPUTS ; 19 JUN 87
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
+3 SET DIC="^DPT("
SET L=0
SET BY="'.1,"
+4 SET FR=","
SET TO=","
IF $DATA(^DG(43,1,"GL"))
if $PIECE(^("GL"),U,2)
SET BY=BY_".19,"
SET FR=FR_","
SET TO=TO_","
+5 SET BY=BY_"@SEX,.01"
SET FR=FR_"E,"
SET TO=TO_"F,"
SET X=3
SET DGNO=0
DO ^DGTEMP
if DGNO
GOTO Q
SET FLDS=X
+6 DO EN1^DIP
Q KILL BY,TO,FR,DIC,DIS,X,DGNO,DHD
QUIT
EN KILL TD,DGF
SET %DT="AEPT"
SET %DT("A")="Enter date of Stay: "
DO ^%DT
if Y'>0
GOTO Q1
if +Y>(DT+1)
GOTO EN
SET DGT=+Y
SET DG2=DGT
SET L=0
SET DGT=$SELECT(DGT[".":DGT,1:DGT_".2400")
SET DG2=DGT
EN1 SET Y=DGT
XECUTE ^DD("DD")
SET DHD="FEMALE INPATIENT FOR "_Y
SET L=0
+1 SET DIS(1)="S DFN=D0 D ^DGINPW,SET^DGFI I DG1 S ^UTILITY($J,""DG"",D0)=DG1"
+2 SET DIC="^DPT("
SET BY="@SEX"
SET X=4
SET DGNO=0
DO ^DGTEMP
if DGNO
GOTO Q
SET FLDS=X
SET FR="F,"
SET TO="FZ,"
+3 IF '$DATA(TD)
IF $DATA(^DG(43,1,"GL"))
if $PIECE(^("GL"),U,2)
SET BY=BY_",999;""DIVISION: """
SET FR=FR_"@,"
SET TO=TO_","
+4 SET BY=BY_",.01"
DO EN1^DIP
+5 if $DATA(DGF)
QUIT
KILL DGT
Q1 KILL %DT,DFN,DG1,DG2,DGA1,DGX,FLDS,L,POP,^UTILITY($JOB,"DG")
GOTO Q
SET if 'DG1
QUIT
SET $PIECE(DG1,U,4)=+DG1
SET $PIECE(DG1,U,1)=+^DGPM(DGA1,0)
SET X=$PIECE(DG1,U,2)
SET $PIECE(DG1,U,10)=$SELECT(X]"":$PIECE(^DG(405.4,+X,0),"^",1),1:"")
IF $PIECE(DG1,U,3)]""
IF "^1^2^3^13^25^26^43^44^45^"[("^"_$PIECE(DG1,U,3)_"^")
SET DG1=""
