- DGFI ;ALB/JDS-MRL - FEMALE INPATIENT OUTPUTS ; 19 JUN 87
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- ;
- 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=""
- DGFI ;ALB/JDS-MRL - FEMALE INPATIENT OUTPUTS ; 19 JUN 87
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- +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=""
