DGPMHST.m

DGPMHST ;ALB/JDS - HISTORICAL INPATIENT OUTPUT- FORMERLY DGIN ;01 JAN 1986

 ;;5.3;Registration;;Aug 13, 1993

 ;

 ;  NOTE:  This used to be named DGIN

 ;                               ----

EN K TD,DGF S %DT="AEXPT",%DT("A")="Enter date of Stay: " D ^%DT G Q: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="INPATIENT LIST FOR "_Y,L=0

EN2 S DIS(1)="D SET^DGPMHST I DG1 S ^UTILITY($J,""DG"",DFN)=DG1"

 S DIC("A")="Enter WARD: ",DIC="^DGPM(",FLDS="[DGPM INPATIENT PRINT]",FR=",",TO=DGT_"," K BY

 I '$D(TD),$D(^DG(43,1,"GL")),$P(^("GL"),U,2) S BY="[DGPM INP HISTORICAL DIVISION]" S FR=FR_"@,",TO=TO_","

 I '$D(BY) S BY="[DGPM INP HISTORICAL 1 DIVISION]"

 S FR=FR_"?,",TO=TO_"?,"

 D EN1^DIP

Q Q:$D(DGF)  K DGT,^UTILITY($J,"DG")

 K %DT,%X,%H,DFN,DG1,DGA1,DGX,DP,P,DGXFR0,B,%Y,DG2,DNP,FLDS,FR,TO,%,DHD,DIS,K,L,POP,X,X1 Q

SET S DG1=0 Q:'$D(^DGPM(D0,0))  Q:$P(^DGPM(D0,0),"^",3)']""  S DFN=$P(^DGPM(D0,0),U,3) Q:$D(^UTILITY($J,"DG1",DFN))  S ^(DFN)=1

 D ^DGPMSTAT

 Q:'DG1  S $P(DG1,U,4)=+DG1,$P(DG1,U,1)=+^DGPM(DGA1,0) I $P(^(0),U,17)]"" S $P(DG1,U,6)=+^DGPM($P(^(0),U,17),0)

 I $P(DG1,U,3) S $P(DG1,U,5)=+DGXFR0 S A=$P(DG1,U,3),$P(DG1,U,7)=$S(A=1:1,A=2:2,A=3:3,A=25:3,"^43^45^"[(U_A_U):4,1:0)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DGPMHST   1268     printed  Mar 13, 2025@21:54:29                                                                                                                                                                                                     Page 2

DGPMHST   ;ALB/JDS - HISTORICAL INPATIENT OUTPUT- FORMERLY DGIN ;01 JAN 1986

 +1       ;;5.3;Registration;;Aug 13, 1993

 +2       ;

 +3       ;  NOTE:  This used to be named DGIN

 +4       ;                               ----

EN         KILL TD,DGF

           SET %DT="AEXPT"

           SET %DT("A")="Enter date of Stay: "

           DO ^%DT

           if Y'>0

               GOTO Q

           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="INPATIENT LIST FOR "_Y

           SET L=0

EN2        SET DIS(1)="D SET^DGPMHST I DG1 S ^UTILITY($J,""DG"",DFN)=DG1"

 +1        SET DIC("A")="Enter WARD: "

           SET DIC="^DGPM("

           SET FLDS="[DGPM INPATIENT PRINT]"

           SET FR=","

           SET TO=DGT_","

           KILL BY

 +2        IF '$DATA(TD)

               IF $DATA(^DG(43,1,"GL"))

                   IF $PIECE(^("GL"),U,2)

                       SET BY="[DGPM INP HISTORICAL DIVISION]"

                       SET FR=FR_"@,"

                       SET TO=TO_","

 +3        IF '$DATA(BY)

               SET BY="[DGPM INP HISTORICAL 1 DIVISION]"

 +4        SET FR=FR_"?,"

           SET TO=TO_"?,"

 +5        DO EN1^DIP

Q          if $DATA(DGF)

               QUIT 

           KILL DGT,^UTILITY($JOB,"DG")

 +1        KILL %DT,%X,%H,DFN,DG1,DGA1,DGX,DP,P,DGXFR0,B,%Y,DG2,DNP,FLDS,FR,TO,%,DHD,DIS,K,L,POP,X,X1

           QUIT 

SET        SET DG1=0

           if '$DATA(^DGPM(D0,0))

               QUIT 

           if $PIECE(^DGPM(D0,0),"^",3)']""

               QUIT 

           SET DFN=$PIECE(^DGPM(D0,0),U,3)

           if $DATA(^UTILITY($JOB,"DG1",DFN))

               QUIT 

           SET ^(DFN)=1

 +1        DO ^DGPMSTAT

 +2        if 'DG1

               QUIT 

           SET $PIECE(DG1,U,4)=+DG1

           SET $PIECE(DG1,U,1)=+^DGPM(DGA1,0)

           IF $PIECE(^(0),U,17)]""

               SET $PIECE(DG1,U,6)=+^DGPM($PIECE(^(0),U,17),0)

 +3        IF $PIECE(DG1,U,3)

               SET $PIECE(DG1,U,5)=+DGXFR0

               SET A=$PIECE(DG1,U,3)

               SET $PIECE(DG1,U,7)=$SELECT(A=1:1,A=2:2,A=3:3,A=25:3,"^43^45^"[(U_A_U):4,1:0)