ACHSPQTS.m

ACHSPQTS ;IHS/ITSC/JVK- TEST DOCUMENTS IN "PQ" WITHOUT ESIG [ 03/28/2005  11:29 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**12**;JUN 11, 2001

 ;ITSC/SET/JVK-PROGRAMMER UTILITY MENU

TEST ;-EN FOR FIXING DOCUMENTS NOT SIGNED- 

 S ACHSEFL=""

 I $D(^ACHSESIG(DUZ(2))) S ACHSEFL=$P($G(^ACHSESIG(DUZ(2),0)),U,2,3)

 I ACHSEFL'="" D MOVE

 Q

MOVE ;

 S ACHSTYPV=""

 S COUNT=0

 F  S ACHSTYPV=$O(^ACHSF("PQ",DUZ(2),ACHSTYPV)) Q:ACHSTYPV'?1N.N  D

 . S ACHSDIEN=""

 . F  S ACHSDIEN=$O(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN)) Q:+ACHSDIEN=0  D

 ..I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2 Q

 ..I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,12)>1 Q

 ..I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,2)<$P(^ACHSESIG(DUZ(2),0),U,3) Q

 ..;I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)="" S COUNT=COUNT+1  W COUNT,"  ",ACHSDIEN,"  " 

 ..;I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,28)="" W ACHSDIEN,!

 ..I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)="" S ^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN,1)=""

 .Q

ACHSPQTS  ;IHS/ITSC/JVK- TEST DOCUMENTS IN "PQ" WITHOUT ESIG [ 03/28/2005  11:29 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**12**;JUN 11, 2001

 +2       ;ITSC/SET/JVK-PROGRAMMER UTILITY MENU

TEST      ;-EN FOR FIXING DOCUMENTS NOT SIGNED- 

 +1        SET ACHSEFL=""

 +2        IF $DATA(^ACHSESIG(DUZ(2)))

               SET ACHSEFL=$PIECE($GET(^ACHSESIG(DUZ(2),0)),U,2,3)

 +3        IF ACHSEFL'=""

               DO MOVE

 +4        QUIT 

MOVE      ;

 +1        SET ACHSTYPV=""

 +2        SET COUNT=0

 +3        FOR 

               SET ACHSTYPV=$ORDER(^ACHSF("PQ",DUZ(2),ACHSTYPV))

               IF ACHSTYPV'?1N.N

                   QUIT 

               Begin DoDot:1

 +4                SET ACHSDIEN=""

 +5                FOR 

                       SET ACHSDIEN=$ORDER(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN))

                       IF +ACHSDIEN=0

                           QUIT 

                       Begin DoDot:2

 +6                        IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2

                               QUIT 

 +7                        IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,12)>1

                               QUIT 

 +8                        IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,2)<$PIECE(^ACHSESIG(DUZ(2),0),U,3)

                               QUIT 

 +9       ;I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)="" S COUNT=COUNT+1  W COUNT,"  ",ACHSDIEN,"  " 

 +10      ;I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,28)="" W ACHSDIEN,!

 +11                       IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)=""

                               SET ^ACHSF("EQ",DUZ(2),ACHSTYPV,ACHSDIEN,1)=""

                       End DoDot:2

 +12               QUIT 

               End DoDot:1