- PSNEWCLS ;BIR/DMA-NOTIFY OF CLASS CHANGES ; 17 Jun 2009 7:08 AM
- ;;4.0; NATIONAL DRUG FILE;**176,100**; 30 Oct 98;Build 5
- ;
- ;Reference to UPDATE^GMRAUTL2 supported by DBIA #4667
- ;
- K ^TMP("PSN1",$J),^TMP("PSNN",$J) N CLASS,DA,DIE,DR,LIN,NC,OC,PR,PSDA,PSNG,PSNGD,PSNK,X,XMDUZ,XMSUB,XMTEXT,XMY
- S DA=0 F S DA=$O(^TMP("PSN",$J,DA)) Q:'DA S PSDA=^(DA,0) D
- .K CLASS S CLASS("D",$P(PSDA,"^",2))="",CLASS("A",$P(PSDA,"^",3))="",X=$P(PSDA,"^",4)_";PSNDF(50.6,^"_$P(^PSNDF(50.6,$P(PSDA,"^",4),0),"^")
- .S PSNG=$P(^PSNDF(50.68,DA,0),"^",2),PSNK=0,PSNGD=0 F S PSNGD=$O(^PSNDF(50.6,"APRO",PSNG,PSNGD)) Q:'PSNGD I $P(^PSNDF(50.68,PSNGD,3),"^")=$P(PSDA,"^",2) S PSNK=1 Q
- .I PSNK K CLASS("D")
- .I $T(UPDATE^GMRAUTL2)]"" D UPDATE^GMRAUTL2(X,,.CLASS)
- .S PR=$P(^PSNDF(50.68,+PSDA,0),"^"),OC=$P(^PS(50.605,$P(PSDA,"^",2),0),"^"),NC=$P(^PS(50.605,$P(PSDA,"^",3),0),"^"),^TMP("PSN1",$J,PR_"^"_OC_"^"_NC)=""
- ;
- S LIN=1,DA="" F S DA=$O(^TMP("PSN1",$J,DA)) Q:DA="" S ^TMP("PSNN",$J,LIN,0)="Product: "_$P(DA,"^"),^TMP("PSNN",$J,LIN+1,0)="Old Class: "_$P(DA,"^",2),^TMP("PSNN",$J,LIN+2,0)="New Class: "_$P(DA,"^",3),^TMP("PSNN",$J,LIN+3,0)=" ",LIN=LIN+4
- ;
- K XMY S XMY(DUZ)="",XMY("G.NDF DATA@"_^XMB("NETNAME"))="" S DA=0 F S DA=$O(^XUSEC("PSNMGR",DA)) Q:'DA S XMY(DA)=""
- S XMDUZ="NDF MANAGER",XMSUB="Products with changed classes",XMTEXT="^TMP(""PSNN"",$J," D ^XMD
- ;
- K CLASS,DA,DIE,DR,LIN,NC,OC,PR,PSDA,PSNG,PSNGD,PSNK,X,XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSN1",$J),^TMP("PSNN",$J) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNEWCLS 1492 printed Mar 13, 2025@21:28:42 Page 2
- PSNEWCLS ;BIR/DMA-NOTIFY OF CLASS CHANGES ; 17 Jun 2009 7:08 AM
- +1 ;;4.0; NATIONAL DRUG FILE;**176,100**; 30 Oct 98;Build 5
- +2 ;
- +3 ;Reference to UPDATE^GMRAUTL2 supported by DBIA #4667
- +4 ;
- +5 KILL ^TMP("PSN1",$JOB),^TMP("PSNN",$JOB)
- NEW CLASS,DA,DIE,DR,LIN,NC,OC,PR,PSDA,PSNG,PSNGD,PSNK,X,XMDUZ,XMSUB,XMTEXT,XMY
- +6 SET DA=0
- FOR
- SET DA=$ORDER(^TMP("PSN",$JOB,DA))
- if 'DA
- QUIT
- SET PSDA=^(DA,0)
- Begin DoDot:1
- +7 KILL CLASS
- SET CLASS("D",$PIECE(PSDA,"^",2))=""
- SET CLASS("A",$PIECE(PSDA,"^",3))=""
- SET X=$PIECE(PSDA,"^",4)_";PSNDF(50.6,^"_$PIECE(^PSNDF(50.6,$PIECE(PSDA,"^",4),0),"^")
- +8 SET PSNG=$PIECE(^PSNDF(50.68,DA,0),"^",2)
- SET PSNK=0
- SET PSNGD=0
- FOR
- SET PSNGD=$ORDER(^PSNDF(50.6,"APRO",PSNG,PSNGD))
- if 'PSNGD
- QUIT
- IF $PIECE(^PSNDF(50.68,PSNGD,3),"^")=$PIECE(PSDA,"^",2)
- SET PSNK=1
- QUIT
- +9 IF PSNK
- KILL CLASS("D")
- +10 IF $TEXT(UPDATE^GMRAUTL2)]""
- DO UPDATE^GMRAUTL2(X,,.CLASS)
- +11 SET PR=$PIECE(^PSNDF(50.68,+PSDA,0),"^")
- SET OC=$PIECE(^PS(50.605,$PIECE(PSDA,"^",2),0),"^")
- SET NC=$PIECE(^PS(50.605,$PIECE(PSDA,"^",3),0),"^")
- SET ^TMP("PSN1",$JOB,PR_"^"_OC_"^"_NC)=""
- End DoDot:1
- +12 ;
- +13 SET LIN=1
- SET DA=""
- FOR
- SET DA=$ORDER(^TMP("PSN1",$JOB,DA))
- if DA=""
- QUIT
- SET ^TMP("PSNN",$JOB,LIN,0)="Product: "_$PIECE(DA,"^")
- SET ^TMP("PSNN",$JOB,LIN+1,0)="Old Class: "_$PIECE(DA,"^",2)
- SET ^TMP("PSNN",$JOB,LIN+2,0)="New Class: "_$PIECE(DA,"^",3)
- SET ^TMP("PSNN",$JOB,LIN+3,0)=" "
- SET LIN=LIN+4
- +14 ;
- +15 KILL XMY
- SET XMY(DUZ)=""
- SET XMY("G.NDF DATA@"_^XMB("NETNAME"))=""
- SET DA=0
- FOR
- SET DA=$ORDER(^XUSEC("PSNMGR",DA))
- if 'DA
- QUIT
- SET XMY(DA)=""
- +16 SET XMDUZ="NDF MANAGER"
- SET XMSUB="Products with changed classes"
- SET XMTEXT="^TMP(""PSNN"",$J,"
- DO ^XMD
- +17 ;
- +18 KILL CLASS,DA,DIE,DR,LIN,NC,OC,PR,PSDA,PSNG,PSNGD,PSNK,X,XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSN1",$JOB),^TMP("PSNN",$JOB)
- QUIT
