DGPTFMO1.m

DGPTFMO1 ;ALB/AS - DGPTF PRINT TEMPLATE (cont) ; 5 FEB 90 14:00

 ;;5.3;Registration;**54**;Aug 13, 1993

 ;

PTF ; -- PTF inquiry

 S FLDS="[DGPTF]"

 S DIC("S")="I $P(^(0),U,11)=1,DG1'[(U_+Y_U)"

 D INQ Q

 ;

CEN ; -- census inquiry

 S FLDS="[DGPT CENSUS INQUIRY]"

 S DIC("S")="N DGPTIFN S DGPTIFN=Y D SCR^DGPTFMO1"

 D INQ Q

INQ ;

 K ^TMP("DGPT INQ",$J)

 S DG1=U,(DIC,DI)="^DGPT(",DIC(0)="AEMQ",L=+$P(^DGPT(0),U,2)

 F DGZZ=1:1 D ^DIC Q:Y'>0  S ^TMP("DGPT INQ",$J,DGZZ,+Y)="",DG1=DG1_+Y_U,DIC("A")="ANOTHER ONE: " Q:$L(DG1)>230

 K DGZZ I '$D(^TMP("DGPT INQ",$J))!(X=U) G Q

 S ZTSAVE("^TMP(""DGPT INQ"",$J,")="",DIOEND="K ^TMP(""DGPT INQ"",$J)"

 S BY="#PATIENT",(FR,TO)="",BY(0)="^TMP(""DGPT INQ"",$J,",L=0,L(0)=2 D EN1^DIP

 K ZTSAVE("^TMP(""DGPT INQ"",$J,")

Q K DGPMCA,DGPMAN,DIC,DI,X,DFN,DG1,DGAD,DGADM,FLDS,L,Y,^TMP("DGPT INQ",$J) Q

 ;

SCR ; -- screen to find census recs or ptf needing census

 ;  input: DGPTIFN ifn of 45

 ; output: $T

 ;

 N DGTEST,I,DGCUR,PTF,DGCI,D0,Y

 I $P(^DGPT(DGPTIFN,0),U,11)=2 S DGTEST=1 G SCRQ

 S DGTEST=0,DGCUR=$O(^DG(45.86,"AC",1,0))

 I DGCUR F I=0:0 S I=$O(^DG(45.85,"PTF",DGPTIFN,I)) Q:'I  I $D(^DG(45.85,I,0)),$P(^(0),"^",4)=DGCUR S DGTEST=1,D0=I D CREC^DGPTCO1 S:X DGTEST=0 Q

SCRQ I DGTEST

 Q

 ;

OPT ; -- screen for comp rpt ; NEW command doesn't pass DIM

 Q:'$D(^DGPT(D0,0))  N DGPTIFN S DGPTIFN=D0 D SCR

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DGPTFMO1   1374     printed  Apr 09, 2024@21:51:53                                                                                                                                                                                                    Page 2

DGPTFMO1  ;ALB/AS - DGPTF PRINT TEMPLATE (cont) ; 5 FEB 90 14:00

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

 +2       ;

PTF       ; -- PTF inquiry

 +1        SET FLDS="[DGPTF]"

 +2        SET DIC("S")="I $P(^(0),U,11)=1,DG1'[(U_+Y_U)"

 +3        DO INQ

           QUIT 

 +4       ;

CEN       ; -- census inquiry

 +1        SET FLDS="[DGPT CENSUS INQUIRY]"

 +2        SET DIC("S")="N DGPTIFN S DGPTIFN=Y D SCR^DGPTFMO1"

 +3        DO INQ

           QUIT 

INQ       ;

 +1        KILL ^TMP("DGPT INQ",$JOB)

 +2        SET DG1=U

           SET (DIC,DI)="^DGPT("

           SET DIC(0)="AEMQ"

           SET L=+$PIECE(^DGPT(0),U,2)

 +3        FOR DGZZ=1:1

               DO ^DIC

               if Y'>0

                   QUIT 

               SET ^TMP("DGPT INQ",$JOB,DGZZ,+Y)=""

               SET DG1=DG1_+Y_U

               SET DIC("A")="ANOTHER ONE: "

               if $LENGTH(DG1)>230

                   QUIT 

 +4        KILL DGZZ

           IF '$DATA(^TMP("DGPT INQ",$JOB))!(X=U)

               GOTO Q

 +5        SET ZTSAVE("^TMP(""DGPT INQ"",$J,")=""

           SET DIOEND="K ^TMP(""DGPT INQ"",$J)"

 +6        SET BY="#PATIENT"

           SET (FR,TO)=""

           SET BY(0)="^TMP(""DGPT INQ"",$J,"

           SET L=0

           SET L(0)=2

           DO EN1^DIP

 +7        KILL ZTSAVE("^TMP(""DGPT INQ"",$J,")

Q          KILL DGPMCA,DGPMAN,DIC,DI,X,DFN,DG1,DGAD,DGADM,FLDS,L,Y,^TMP("DGPT INQ",$JOB)

           QUIT 

 +1       ;

SCR       ; -- screen to find census recs or ptf needing census

 +1       ;  input: DGPTIFN ifn of 45

 +2       ; output: $T

 +3       ;

 +4        NEW DGTEST,I,DGCUR,PTF,DGCI,D0,Y

 +5        IF $PIECE(^DGPT(DGPTIFN,0),U,11)=2

               SET DGTEST=1

               GOTO SCRQ

 +6        SET DGTEST=0

           SET DGCUR=$ORDER(^DG(45.86,"AC",1,0))

 +7        IF DGCUR

               FOR I=0:0

                   SET I=$ORDER(^DG(45.85,"PTF",DGPTIFN,I))

                   if 'I

                       QUIT 

                   IF $DATA(^DG(45.85,I,0))

                       IF $PIECE(^(0),"^",4)=DGCUR

                           SET DGTEST=1

                           SET D0=I

                           DO CREC^DGPTCO1

                           if X

                               SET DGTEST=0

                           QUIT 

SCRQ       IF DGTEST

 +1        QUIT 

 +2       ;

OPT       ; -- screen for comp rpt ; NEW command doesn't pass DIM

 +1        if '$DATA(^DGPT(D0,0))

               QUIT 

           NEW DGPTIFN

           SET DGPTIFN=D0

           DO SCR

 +2        QUIT